home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / errors.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  9.4 KB  |  308 lines  |  [TEXT/CCL2]
  1. ;;; This file contains general error handling routines.
  2.  
  3. ;;; This is the general error handler.  It has three arguments: an
  4. ;;; id, error type, and an error message.  The message is a list of
  5. ;;; format, arglist combinations.
  6.  
  7. ;;; The error types are:
  8. ;;;   warning       -> control returns and compilation proceeds
  9. ;;;                    The message may be suppressed
  10. ;;;   recoverable   -> control returns and compilation proceeds
  11. ;;;   phase         -> control returns but compilation is aborted
  12. ;;;                         after the phase in *abort-point*.
  13. ;;;   fatal         -> control goes back to the top level
  14. ;;;   internal      -> enters the break loop or does a fatal error
  15.  
  16. ;;; Two globals control error behavior:
  17. ;;;   *break-on-error?* enter the break loop on any error
  18. ;;;   *never-break?* never enter the break loop, even for internal errors.
  19.  
  20. (define *break-on-error?* '#f)
  21. (define *never-break?* '#f)
  22.  
  23. ;;; The global *error-output-port* controls where errors are printer.
  24.  
  25. (define (format-error-msg . args)
  26.   (apply (function format) *error-output-port* args))
  27.  
  28. ;;; The strategy here is to first write a banner message based on the id and
  29. ;;; type, write out the messages, and then take action depending on the type.
  30.  
  31. (define *in-error-handler?* '#f)
  32.  
  33. (define (haskell-error id type messages)
  34.   (declare (ignore id))
  35.   (dolist (m messages)
  36.     (apply (function format) *error-output-port* m)
  37.     (fresh-line *error-output-port*))
  38.   (maybe-show-context (dynamic *context*))
  39.   (format *error-output-port* "~%")  ; add a blank between error messages
  40.   (if (dynamic *in-error-handler?*)
  41.       (error "Recursive error in haskell-error.")
  42.       (begin
  43.         (dynamic-let ((*in-error-handler?*  '#t))
  44.       (cond (*break-on-error?*
  45.          (haskell-breakpoint))
  46.         ((eq? type 'internal)
  47.          (if *never-break?*
  48.              (abort-compilation)
  49.              (haskell-breakpoint)))
  50.         ((eq? type 'fatal)
  51.          (abort-compilation))
  52.         ((eq? type 'phase)
  53.          (halt-compilation))))
  54.     (when (and (memq type '(recoverable phase))
  55.            (dynamic *recoverable-error-handler*))
  56.       (funcall (dynamic *recoverable-error-handler*)))
  57.     'ok)))
  58.  
  59. (define (err-type->banner err-type)
  60.   (cond ((eq? err-type 'warning)
  61.      "Warning: ")
  62.     ((eq? err-type 'recoverable)
  63.      "")
  64.     ((eq? err-type 'phase)
  65.      "")
  66.     ((eq? err-type 'fatal)
  67.      "")    
  68.     ((eq? err-type 'internal)
  69.      "Internal-error: ")
  70.     (else "???")))
  71.  
  72. (define (maybe-show-context context)
  73.   (when context
  74.     (with-slots source-pointer (line file) (ast-node-line-number context)
  75.       (fresh-line *error-output-port*)
  76.       (if (< line 0)
  77.       (format *error-output-port* "Error occured in `~A'" file)
  78.       (format *error-output-port* "Error occurred at line ~A in file ~A.~%"
  79.           line file)))))
  80.  
  81. (define (get-context-file context)
  82.   (if context (source-pointer-file (ast-node-line-number context)) "unknown"))
  83.  
  84. (define (get-context-line context)
  85.   (if context (source-pointer-line (ast-node-line-number context)) "unknown"))
  86.  
  87. ;;; A few entry points into the error system.
  88. ;;; As a matter of convention, there should be a signaling function defined
  89. ;;; for each specific error condition that calls one of these functions.
  90. ;;; Error messages should be complete sentences with proper punctuation
  91. ;;; and capitalization.  The signaling function should use the message
  92. ;;; to report the error and not do any printing of its own.
  93.  
  94. (define (fatal-error id . msg)
  95.  (haskell-error id 'fatal (list msg)))
  96.  
  97. (define (haskell-warning id . msg)
  98.  (haskell-error id 'warning (list msg)))
  99.  
  100. (define (recoverable-error id . msg)
  101.  (haskell-error id 'recoverable (list msg)))
  102.  
  103. (define (compiler-error id . msg)
  104.  (haskell-error id 'internal (list msg)))
  105.  
  106. (define (phase-error id . msg)
  107.  (haskell-error id 'phase (list msg)))
  108.  
  109. (define (phase-error/objs id objs . msg)
  110.   (haskell-error id 'phase
  111.     (cons msg (concat (map (function show-definition-point) objs)))))
  112.  
  113. ;;; This function puts the compiler into the lisp breakloop.  this may
  114. ;;; want to fiddle the programming envoronment someday.
  115.  
  116. (define (haskell-breakpoint)
  117.  (error "Haskell breakpoint."))
  118.  
  119.  
  120. ;;; This deals with error at runtime
  121.  
  122. (define *haskell-backtrace-depth* 50)
  123. (define *haskell-backtrace* '#f)
  124.  
  125. (define *runtime-abort* '())
  126.  
  127. (define (haskell-runtime-error msg)
  128.   (format '#t "~&~%Haskell runtime abort.~%~A~%" msg)
  129.   (haskell-backtrace)
  130.   (funcall (dynamic *runtime-abort*)))
  131.  
  132. (define (haskell-backtrace)
  133.   (when *haskell-backtrace*
  134.     (backtrace *haskell-backtrace-depth*)))
  135.  
  136.  
  137. ;; Some common error handlers
  138.  
  139. (define (signal-unknown-file-type filename)
  140.   (fatal-error 'unknown-file-type
  141.     "The filename ~a has an unknown file type."
  142.     filename))
  143.  
  144. (define (signal-file-not-found filename)
  145.   (fatal-error 'file-not-found
  146.     "The file ~a doesn't exist."
  147.     filename))
  148.                                                        
  149. ;;; This is support for undefined name messages.
  150.  
  151. (define *undefined-syms* '())
  152.  
  153. (define (watch-for-undefined-symbols)
  154.   (setf *undefined-syms* '()))
  155.  
  156. (define (remember-undefined-symbol ty name)
  157.   (let ((alist (assq *module-name* *undefined-syms*))
  158.     (r (list ty name *context*)))
  159.     (if alist
  160.     (setf (cdr alist) (cons r (cdr alist)))
  161.     (push (cons *module-name* (list r)) *undefined-syms*))))
  162.  
  163. (define (show-undefined-symbols)
  164.   (if (null? *undefined-syms*)
  165.       'ok
  166.       (let* ((first-syms (cdr (car *undefined-syms*)))
  167.          (first-context (caddr (car first-syms)))
  168.          (l (get-context-line first-context)))
  169.     (if (and (number? l) (< l 0))
  170.         (if (null? (cdr first-syms))
  171.         (format-error-msg
  172.            "The name `~A' is undefined in the expression `~A'~%"
  173.            (cadr (car first-syms))
  174.            (get-context-file first-context))
  175.         (begin
  176.           (format-error-msg
  177.            "The expression `~A' contains undefined names:~%"
  178.            (get-context-file first-context))
  179.           (show-undefined-syms (tuple-2-2 (car *undefined-syms*)) '#f)))
  180.         (begin
  181.           (format-error-msg "Undefined names are present~%")
  182.           (dolist (alist *undefined-syms*)
  183.          (format-error-msg "In module ~A (file ~A):~%"
  184.               (tuple-2-1 alist)
  185.               (get-context-file (caddr (car (tuple-2-2 alist)))))
  186.          (show-undefined-syms (tuple-2-2 alist) '#t))))
  187.     (halt-compilation))))
  188.  
  189. (define (show-undefined-syms refs show-lines?)
  190.   (when refs
  191.    (mlet ((kind (car (car refs)))
  192.       (name (cadr (car refs)))
  193.       ((line-nums refs1) (find-refs-to-name kind name refs))
  194.       (kind-name (cond ((eq? kind 'var) "Variable")
  195.                ((eq? kind 'algdata) "Type")
  196.                ((eq? kind 'class) "Class")
  197.                ((eq? kind 'deriving) "Deriving")
  198.                ((eq? kind 'con) "Constructor")
  199.                (else kind))))
  200.       (if show-lines?
  201.       (begin
  202.         (format-error-msg "~A ~A, referenced at line~A "
  203.              kind-name
  204.              name
  205.              (if (null? (cdr line-nums)) "" "s"))
  206.         (let ((c '#f))
  207.           (dolist (l (reverse line-nums))
  208.             (format-error-msg "~A~A" (if c ", " "") l)
  209.         (setf c '#t)))
  210.         (format-error-msg "~%"))
  211.       (format-error-msg "~A ~A~%" kind-name name))
  212.        (show-undefined-syms refs1 show-lines?))))
  213.  
  214. (define (find-refs-to-name ty name refs)
  215.   (if refs
  216.       (mlet (((r1 rest) (find-refs-to-name ty name (cdr refs))))
  217.     (if (and (eq? ty (car (car refs))) (eq? name (cadr (car refs))))
  218.         (values (cons (get-context-line (caddr (car refs))) r1) rest)
  219.         (values r1 (cons (car refs) rest))))
  220.       (values '() '())))
  221.  
  222. ;;; These routines show where an object is defined.
  223.  
  224. (define (show-definition-point obj)
  225.   (let ((sp (cond ((is-type? 'def obj)
  226.            (def-where-defined obj))
  227.           ((is-type? 'ast-node obj)
  228.            (ast-node-line-number obj))
  229.           (else '#f))))
  230.     (if sp
  231.     (list (list "~A ~A is defined at line ~A in file ~A"
  232.             (get-object-kind obj)
  233.             (get-object-name obj)
  234.             (source-pointer-line sp)
  235.             (source-pointer-file sp)))
  236.     '())))
  237.  
  238. (define (get-object-name def)
  239.   (cond ((eq? def (core-symbol "List")) "[]")
  240.     ((eq? def (core-symbol "UnitType")) "()")
  241.     ((eq? def (core-symbol "Arrow")) "(->)")
  242.     ((con? def)
  243.      (remove-con-prefix (symbol->string (def-name def))))
  244.     ((is-type? 'deriving def)
  245.      (remove-di-prefix/string (symbol->string (def-name def))))
  246.     ((is-type? 'def def)
  247.      (symbol->string (def-name def)))
  248.     ((instance? def)
  249.      (format '#f "~A(~A)" (get-object-name (instance-class def))
  250.                       (get-object-name (instance-algdata def))))
  251.     ((is-type? 'module def)
  252.      (symbol->string (module-name def)))
  253.     (else "unknown object")))
  254.  
  255. (define (get-object-kind def)
  256.   (cond ((method-var? def)
  257.      "Method variable")
  258.     ((var? def)
  259.      "Variable")
  260.     ((con? def)
  261.      "Constructor")
  262.     ((algdata? def)
  263.      "Data type")
  264.     ((synonym? def)
  265.      "Type synonym")
  266.     ((class? def)
  267.      "Class")
  268.     ((instance? def)
  269.      "Instance")
  270.     ((and (is-type? 'module def)
  271.           (interface-module? def))
  272.      "Interface")
  273.     ((is-type? 'module def)
  274.      "Module")
  275.     ((is-type? 'deriving def)
  276.      "Derived instance")
  277.     (else "unknown")))
  278.  
  279.  
  280. ;;; While it would be nice to redo the formatting language a bit for error
  281. ;;; messages, for the moment most formatting is done outside the format
  282. ;;; string using a few simple functions.  These all have short names so that
  283.  
  284. ;;; The basic routine here is to limit the size of an object embedded within
  285. ;;; a message.
  286.  
  287. (define (sz x n)  ; limit the size of x to n; don't add a newline
  288.   (format-sized x n '#f))
  289.  
  290. (define (szn x n)
  291.   (format-sized x n '#t)) ; limit x and add a newline
  292.  
  293. (predefine (ntype->gtype ty))
  294.  
  295. (define (szt x n)  ; as sz except an ntype is printed.
  296.   (format-sized (ntype->gtype x) n '#f))
  297.  
  298. (define (sznt x n)  ; as sz except an ntype is printed.
  299.   (format-sized (ntype->gtype x) n '#t))
  300.  
  301. ;;; Some generic error handlers
  302.  
  303. (define (signal-bad-annotated-var n a)
  304.   (recoverable-error 'non-local-name-in-annotation
  305. "The variable ~A in annotation ~%~A~%is not defined by this declaration group"
  306.     n a))
  307.  
  308.